home *** CD-ROM | disk | FTP | other *** search
Text File | 1993-02-18 | 66.5 KB | 1,837 lines |
- *-------------------------------------------------------------------------------
- *-- Program..: PICKLIST.PRG
- *-- Date.....: 01/27/1993
- *-- Notes....: This new (as of November, 1992) section of the DUFLP library is
- *-- designed to be a place where a variety of picklist routines
- *-- will be stored. You can ... ahem ... pick and choose the one(s)
- *-- you need from here.
- *-- WARNING..: Do not save changes with WordStar 5.5 Non_Document mode --
- *-- the diacritical characters in the DIACRIT procedure below
- *-- will not be saved properly (WordStar doesn't like high ASCII
- *-- characters ...)
- *-------------------------------------------------------------------------------
-
- FUNCTION Pick1
- *-------------------------------------------------------------------------------
- *-- Programmer..: Kenneth W. Holloway (HollowayK on BORBBS)
- *-- Date........: 11/06/1992
- *-- Notes.......: Pick List.
- *-- Written for.: dBASE IV, 1.5
- *-- Rev. History: 08/12/1992 0.0 - Original version (KWH)
- *-- 09/11/1992 0.1 - (KWH) Added color settings (x_ClrP*) that
- *-- were Ass-U-Med to be defined elsewhere.
- *-- 09/16/1992 0.2 - (KWH) Added "set key to" at end of function.
- *-- (BORLAND: What happened to set("KEY")?!?!)
- *-- 10/14/1992 0.3 - Added (KenMayer) ability to pass colors
- *-- to program ... removed settings for
- *-- alias, order, key. The reason is a lack
- *-- of stack space to call routine, can only send
- *-- x number of parms. The programmer must
- *-- set the database (select .../Use ...),
- *-- order, and key (set key...) before calling
- *-- this routine, and then reset to prior setting
- *-- (if needed).
- *-- 10/15/1992 0.4 - (KWH) Added code for Tab/Shift Tab. Put the
- *-- setting for key back in, as it is required
- *-- for proper SEEKing with SET KEY in effect.
- *-- 10/19/1992 0.5 - (KWH) Several changes inspired by JOEY:
- *-- ■ Now uses setting of SET BORDER TO when drawing borders.
- *-- ■ Bell only sounds when SET BELL is ON.
- *-- ■ Added code for {Home} and {End}.
- *-- 11/06/1992 0.6 - (KWH) Optimization inspired by KELVIN:
- *-- ■ Removed repetitive recalculation of PICTURE clause
- *-- ■ Removed some dead code
- *-- ■ Added a logical variable for main loop, instead of four
- *-- .and.ed expressions
- *-- Calls.......: ColorBrk() Function in PROC.PRG
- *-- Called by...: Any
- *-- Usage.......: Pick1(cTitle,cDisplay,cReturn[,cKey[,nFromRow,nFromCol
- *-- [,nToRow,nToCol[,cColor1[,cColor2]]]]])
- *-- Example.....: ? Pick1("Client Name","NAME","JOB_CODE","",5,10,20,55,;
- *-- cColor1,cColor2)
- *-- Returns.....: Specified expression, using macro substitution.
- *-- Parameters..: cTitle = Title to be displayed above PickList
- *-- cDisplay = Expression to display, using macro substitution
- *-- Note: If cDisplay includes any chr(29)'s (), the Tab and
- *-- Shift Tab keys can be used to highlight/unhighlight
- *-- everything up to the next/previous chr(29).
- *-- cReturn = Expression to return, using macro substitution
- *-- cKey = Expression for SET KEY TO
- *-- nFromRow \ Upper left corner
- *-- nFromCol / of PickList window
- *-- nToRow \ Lower right corner
- *-- nToCol / of PickList window
- *-- cColor1 = message,title,box
- *-- cColor2 = highlight,selected
- *-- Both cColor1, and cColor2 use specific color
- *-- settings of <Foreground>/<Background> for each
- *-- part of the parm. For example, cColor1 might
- *-- look like: rg+/gb,w+/b,rg+/gb
- *-- Definitions:
- *-- message = unselected items in picklist (w+/rb)
- *-- title = title at top of window (w+/rb)
- *-- box = border (rg+/rb)
- *-- highlight = highlighted item (g+/n)
- *-- selected = selected character(s) (r+/n)
- *-------------------------------------------------------------------------------
-
- parameters cTitle,cDisplay,cReturn,;
- cKey,;
- nFromRow,nFromCol,nToRow,nToCol,;
- cColor1, cColor2
- private all except *_*
- private all like x_ClrP*
-
-
- * Check validity of all parameters
- if pcount()<3
- return "***"+program()+" Error***"
- endif
-
- * Save setting of TALK and turn it off.
- if set("TALK")="ON"
- set talk off
- cTalk = "ON"
- else
- cTalk = "OFF"
- endif
-
- * Save and change settings of other parameters
- cConsole = set("CONSOLE")
- cCursor = set("CURSOR")
- cEscape = set("ESCAPE")
- set cursor off
- set escape off
-
- * Set default values for unspecified parameters
- if type("cKey")="L"
- cKey = ""
- endif
- if type("nFromRow")="L"
- nFromRow = 5
- endif
- if type("nFromCol")="L"
- nFromCol = 5
- endif
-
- if type("cColor1")="L"
- x_ClrPMess = "W+/RB"
- x_ClrPTitl = "W+/RB"
- x_ClrPBox = "RG+/RB"
- else
- x_ClrPMess = colorbrk(cColor1,1)
- x_ClrPTitl = colorbrk(cColor1,2)
- x_ClrPBox = colorbrk(cColor1,3)
- endif
- if type("cColor2")="L"
- x_ClrPHigh = "G+/N"
- x_ClrPSlct = "R+/N"
- else
- x_ClrPHigh = colorbrk(cColor2,1)
- x_ClrPSlct = colorbrk(cColor2,2)
- endif
-
- *-- Real code starts here
- * Setup specified database environment
- if .not.isblank(cKey)
- set key to cKey
- endif
-
- * Calculate value of nToRow
- if type("nToRow")="L"
- goto top
- count to nToRow next 21-nFromRow
- nToRow = nFromRow + max(nToRow,3) + 3
- endif
-
- * Calculate value of nToCol
- if type("nToCol")="L"
- nToCol = nFromCol + max(len(cTitle),len(&cDisplay.)) + 1
- if nToCol>79
- nToCol = 79
- endif
- endif
-
- * Define and activate title window, draw border and title
- define window wPickList1 from nFromRow,nFromCol to nToRow,nToCol none ;
- color &x_ClrPMess.
- activate window wPickList1
- nWindRow = nToRow - nFromRow
- nWindCol = nToCol - nFromCol
- @ 00,00 to nWindRow,nWindCol color &x_ClrPBox.
- @ 01,01 say cTitle color &x_ClrPTitl.
- @ 02,01 to 02,nWindCol-1 color &x_ClrPBox.
- cBorder = set("BORDER")
- do case
- case cBorder="NONE"
- case cBorder="SINGLE"
- @ 02,00 say "├" color &x_ClrPBox.
- @ 02,nWindCol say "┤" color &x_ClrPBox.
- case cBorder="DOUBLE"
- @ 02,00 say "╠" color &x_ClrPBox.
- @ 02,nWindCol say "╣" color &x_ClrPBox.
- case cBorder="PANEL"
- @ 02,00 say "█" color &x_ClrPBox.
- @ 02,nWindCol say "█" color &x_ClrPBox.
- otherwise
- @ 02,00 say chr(val(substr(cBorder,17,3))) color &x_ClrPBox.
- @ 02,nWindCol say chr(val(substr(cBorder,21,3))) color &x_ClrPBox.
- endcase
-
- * Define and activate data window
- define window wPickList2 from nFromRow+3,nFromCol+1 to nToRow-1,nToCol-1 none color &x_ClrPMess.
- activate window wPickList2
- nWindRow = nToRow - nFromRow-4
- nWindCol = nToCol - nFromCol-2
- cWindPict = replicate('X',nWindCol+1)
-
- * Initialize position and status variables
- goto top
- lBell = (set("BELL")="ON")
- nCurRow = 0
- nInkey = 0
- nNewRow = 0
- nRecNo = recno()
- lRepaint = .t.
- cSeek = ""
- lSeek = .F.
- nNewSCur = 0
- nSeekCur = 0
- if eof()
- if lBell
- @ 00,00 say chr(7)
- endif
- @ 00,00 say "*** No records to list ***"
- set console off
- wait
- set console on
- cReturn = ""
- nInkey = 27
- endif
-
-
- *-- Display PickList until Enter .or. Ctrl-Q .or. Ctrl-W or Ctrl-End
- *-- .or. Esc is pressed
- lMore = .T.
- do while lMore
- if lSeek
- seek cKey+cSeek
- nNewSCur = len(cSeek)
- cStr = &cDisplay.
- nPos = at(chr(29),substr(cStr,1,nNewSCur+1))
- do while nPos>0
- cStr = stuff(cStr,nPos,1," ")
- nNewSCur = nNewSCur + 1
- nPos = at(chr(29),substr(cStr,1,nNewSCur+1))
- enddo
- nSeek = recno() && Save new record number
- n = 0 && Counter
- goto nRecNo && Record at top of screen
- * Look to see if new record is on screen
- scan while recno()#nSeek .and. n<nMaxRow
- n = n + 1
- endscan
- if recno()=nSeek && New record is on screen
- nNewRow = n && Put cursor on new record
- else && New record is not on screen
- nNewRow = 0 && Put cursor at top of window
- nRecNo = nSeek && New record at top of window
- lRepaint = .T. && Redisplay window
- endif
- lSeek = .F.
- endif
-
- if lRepaint .or. nNewRow#nCurRow
- * Hide cursor
- @ nCurRow,00 fill to nCurRow,nWindCol color &x_ClrPMess.
- endif
-
- if lRepaint && Need to redisplay entire data window
- goto nRecNo && Record that should be at top of window
- nMaxRow = 0 && Number of rows displayed
- scan while nMaxRow<=nWindRow && nWindRow = number of rows in window
- * Display data
- @ nMaxRow,00 say &cDisplay. picture cWindPict color &x_ClrPMess.
- nMaxRow = nMaxRow + 1 && Increase rows displayed counter
- endscan
- nMaxRow = nMaxRow - 1 && Make rows displayed counter zero-based
-
- if eof() .and. nMaxRow<nWindRow && Didn't fill window?
- * Clear unused portion of window
- @ nMaxRow+1,00 clear to nWindRow,nWindCol
- endif
- endif
-
- if lRepaint .or. nNewRow#nCurRow .or. nNewSCur#nSeekCur
- nSeekCur = nNewSCur && New seek cursor length
- nCurRow = nNewRow && New cursor position
- if nCurRow>nMaxRow && Cursor row invalid? (Caused by PgDn)
- nCurRow = nMaxRow && Put cursor on last displayed row
- endif
-
- * Display cursor
- if nSeekCur>0
- @ nCurRow,00;
- fill to nCurRow,min(nWindCol,nSeekCur-1);
- color &x_ClrPSlct.
- endif
- if nSeekCur<=nWindCol
- @ nCurRow,max(0,nSeekCur);
- fill to nCurRow,nWindCol;
- color &x_ClrPHigh.
- endif
- endif
-
- lRepaint = .F. && Reset redisplay flag
-
- nInkey = inkey(0) && Get a key-stroke
- do case
- case nInkey=-400 && Shift-Tab
- if isblank(cSeek)
- if lBell
- @ 00,00 say chr(7)
- endif
- else
- if len(cSeek)=nSeekCur
- cSeek = ""
- lSeek = .T.
- else
- goto nRecNo && Record at top of window
- skip nCurRow && Cursor row
- * Currently seeked string
- cStr = substr(&cDisplay.,1,nSeekCur)
- * If the last character is a chr(29)
- if substr(cStr,len(cStr),1)=chr(29)
- * Remove the chr(29)
- cStr = substr(cStr,1,len(cStr)-1)
- endif
- * If there is a chr(29)
- if chr(29)$cStr
- * Remove everything after the last chr(29)
- cSeek = substr(cSeek,1,len(cSeek)-len(cStr)+RAt(chr(29),cStr))
- else
- * Remove everything
- cSeek = ""
- endif
- lSeek = .T.
- endif
- endif
-
- case nInkey=3 && PageDown
- cSeek = "" && Clear seek string
- nNewSCur = 0 && Clear seek cursor
- if nCurRow=nMaxRow && Is cursor on last line in window?
- goto nRecNo && Record at top of window
- skip nWindRow+1 && Number of records in window
- if eof()
- if lBell
- @ 00,00 say chr(7) && No more records past bottom of window
- endif
- else
- skip -1 && Put bottom record at top of window
- nRecNo = recno() && New record for top of window
- lRepaint = .T. && Redisplay window
- endif
- else && Cursor is not on last line in window
- nNewRow = nMaxRow && Put cursor on last line in window
- endif
-
- case nInkey=5 && Up Arrow
- cSeek = "" && Clear seek string
- nNewSCur = 0 && Clear seek cursor
- if nCurRow>0 && Is cursor below top of window?
- nNewRow = nCurRow - 1 && Move cursor up
- else && Cursor is at top of window
- goto nRecNo && Record at top of window
- skip -1
- if bof()
- if lBell
- @ 00,00 say chr(7) && No previous record
- endif
- else
- nRecNo = recno() && New record for top of window
- lRepaint = .t. && Redisplay window
- endif
- endif
-
- case nInkey=9 && Tab
- goto nRecNo && Record at top of window
- skip nCurRow && Cursor row
- * Characters after currently seeked string
- cStr = substr(&cDisplay.,nSeekCur+1)
- if (chr(29)$cStr) && Tab marker included?
- * Seek everything up to the tab marker
- cStr = substr(cStr,1,at(chr(29),cStr)-1)
- if .not.seek(cKey+cSeek+cStr)
- cStr = upper(cStr)
- endif
- if seek(cKey+cSeek+cStr)
- cSeek = cSeek + cStr
- lSeek = .T.
- else
- if lBell
- @ 00,00 say chr(7)
- endif
- endif
- else
- if lBell
- @ 00,00 say chr(7)
- endif
- endif
-
- case nInkey=13 .or. nInkey=23 && Enter .or. Ctrl-W or Ctrl-End
- goto nRecNo && Record at top of window
- skip nCurRow && Cursor row
- cReturn = &cReturn. && Return value
- lMore = .F. && Exit main loop
-
- case nInkey=17 .or. nInkey=27 && Ctrl-Q .or. Escape
- cReturn = "" && Return value
- lMore = .F. && Exit main loop
-
- case nInkey=18 && Page Up
- cSeek = "" && Clear seek string
- nNewSCur = 0 && Clear seek cursor
- if nCurRow=0 && Is cursor on top line of window?
- goto nRecNo && Record at top of window
- skip -nWindRow && Number of records in window
- if bof()
- if lBell
- @ 00,00 say chr(7) && No more records above top of window
- endif
- else
- nRecNo = recno() && New record for top of window
- lRepaint = .T. && Redisplay window
- endif
- else && Cursor is not on top line of window
- nNewRow = 0 && Put cursor on top line of window
- endif
-
- case nInkey=24 && Down Arrow
- cSeek = "" && Clear seek string
- nNewSCur = 0 && Clear seek cursor
- if nCurRow<nMaxRow && Is cursor above bottom of window?
- nNewRow = nCurRow + 1 && Move cursor down
- else && Cursor is at bottom of window
- goto nRecNo && Record at top of window
- skip nWindRow+1 && Skip to first record below window
- if eof()
- if lBell
- @ 00,00 say chr(7) && No records below window
- endif
- else
- goto nRecNo && Record at top of window
- skip +1
- nRecNo = recno() && New record for top of window
- lRepaint = .T. && Redisplay window
- endif
- endif
-
- case nInkey=2 .or. nInkey=30 && End .or. Ctrl-Page Down
- cSeek = "" && Clear seek string
- nNewSCur = 0 && Clear seek cursor
- goto bottom && Last record in database
- skip -nWindRow && Number of records in window
- nNewRow = nWindRow && Put cursor on bottom line of window
- nRecNo = recno() && New record for top of window
- lRepaint = .T. && Redisplay window
-
- case nInkey=26 .or. nInkey=31 && Home .or. Ctrl-Page Up
- cSeek = "" && Clear seek string
- nNewSCur = 0 && Clear seek cursor
- goto top && First record in database
- nNewRow = 0 && Put cursor on top line of window
- nRecNo = recno() && New record for top of window
- lRepaint = .T. && Redisplay window
-
- case nInkey>31 .and. nInkey<127 && Displayable character - Seek it
- cInkey = chr(nInkey)
- if .not.seek(cKey+cSeek+cInkey)
- cInkey = upper(cInkey)
- endif
- if seek(cKey+cSeek+cInkey) && Seek with new character
- cSeek = cSeek + cInkey && Add new character to seek string
- lSeek = .T.
- else
- if lBell
- @ 00,00 say chr(7) && Seek with new character failed
- endif
- endif
-
- case nInkey=127 && Back Space
- if len(cSeek)>0 && Seek string is non-blank
- * Remove last character from seek string
- cSeek = left(cSeek,len(cSeek)-1)
- lSeek = .T.
- else
- if lBell
- @ 00,00 say chr(7) && Seek string is blank
- endif
- endif
-
- otherwise && Unknown key
- b=.t. && Breakpoint - used for debugging
- release b
- endcase
- enddo
-
- * Deactivate and release windows
- deactivate window wPickList2
- deactivate window wPickList1
- release windows wPickList1,wPickList2
-
- * Restore database environment
- if .not.isblank(cKey)
- set key to
- endif
-
- *-- Cleanup
- set console &cConsole.
- set cursor &cCursor.
- set escape &cEscape.
- set talk &cTalk.
-
- RETURN cReturn
- *-- EoF: Pick1()
-
- FUNCTION Pick2
- *-------------------------------------------------------------------------------
- *-- Programmer..: Malcolm C. Rubel
- *-- Date........: 05/18/1992
- *-- Notes.......: I stole ... er ... lifted ... this from Data Based Advisor
- *-- (Nov. 1991), and dUFLPed it, as well as removing the FoxPro
- *-- code ...
- *-- It's purpose is to create a popup/picklist that will
- *-- find the proper location (used with a GET) on the
- *-- screen for itself, display the popup and return the
- *-- appropriate value ...
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: 11/xx/1991 -- Malcom C. Rubel -- Original Code
- *-- 05/15/1992 -- Ken Mayer -- several things. First, I dUFLPed
- *-- the code, and documented it heavier than the original.
- *-- Next, I had to write a function (USED()), as there wasn't
- *-- one sitting around that I could see.
- *-- I added the 'cTag' parameter, as well as a few minor changes
- *-- to the other functions that come with this routine ...
- *-- 05/19/1992 -- Resolved a few minor problems, removed routine
- *-- PK_SHOW as being unnecessary (used @nGetRow... GET to
- *-- redisplay field/memvar). Added IsBlank() (copy of EMPTY()) to
- *-- handle different field types (original only wanted characters).
- *-- Calls.......: ScrRow() Function in SCREEN.PRG (and here)
- *-- ScrCol() Function in SCREEN.PRG (and here)
- *-- Used() Function in FILES.PRG (and here)
- *-- Called by...: Any
- *-- Usage.......: Pick2("<cLookFile>","<cTag>","<cSrchFld>","<cRetFld>",;
- *-- <nScrRow>,<nScrCol>)
- *-- Example.....: @10,20 get author ;
- *-- valid required pick2("Library","Author",;
- *-- "Last","Last",10,20)
- *-- Returns.....: lReturn (found/replaced a value or not ...)
- *-- Parameters..: cLookFile = file to lookup in
- *-- cTag = MDX Tag to use (if blank, will use the first
- *-- tag in the MDX file, via the TAG(1) option ...)
- *-- cSrchFld = field(s) to browse -- if blank, function will
- *-- try to use a field of same name as what
- *-- cursor is on.
- *-- cRetFld = name of field value is to be returned from.
- *-- nScrRow = screen-row (of GET) -- if blank, function will
- *-- determine (use ,, to blank it ... or 0)
- *-- nScrCol = screen-col (of GET) -- if blank, function will
- *-- determine
- *-------------------------------------------------------------------------------
-
- parameters cLookFile, cTag, cSrchFld, cRetFld, nScrRow, nScrCol
- private cLookFile,cSrchFld,cRetFld,nScrRow,nScrCol,cVarName,xValReturn,;
- lWasOpen,cCurrBuff,lExact,lReturn,lIsFound,;
- cBarFields,nWinWidth,nGetRow,nGetCol
-
- lReturn = .t. && return value must be a logical ...
- && assume the best ...
- cVarName = varread() && name of the variable at GET
- xVarValue = &cVarName && value of the variable at GET
-
- *-- was a 'fieldname' to get value from passed to function?
- if isblank(cRetFld) && passed as a null
- cRetFld = cSrchFld && we'll return contents of same name
- && as the search field
- endif
-
- nScrRow = ScrRow() && get row for picklist
- nScrCol = ScrCol() && get column for picklist
- cCurrBuff = alias() && current buffer (work area)
- lExact = set("EXACT") = "ON" && store status of 'EXACT'
- set exact on && we want 'exact' matches ...
-
- *-- deal with the 'lookup' file -- if not open, open it, if open,
- *-- select it ...
- if .not. used(cLookFile) && file not open
- select select() && find next open area
- use &cLookFile && open file
- lWasOpen = .f.
- else
- select (cLookFile) && file IS open, move to it ...
- lWasOpen = .t.
- endif
-
- *-- deal with MDX tag for 'lookup' file ...
- if len(trim(cTag)) = 0 && if a null tag was sent,
- set order to Tag(1) && set the order to first tag
- else
- set order to &cTag && set it to what user passed.
- endif
-
- *-- screen positions ...
- nGetRow = row() && position of 'get' on screen
- nGetCol = iif(isblank(xVarValue),col(),col()-len(&cRetFld))
- && get column of 'get' ...
-
- *-- if field is empty, do a lookup, otherwise, look for it in table
- if isblank(xVarValue) && no data in field
- lIsFound = .f. && automatic lookup
- else
- lIsFound = seek(xVarValue) && look for it in table
- endif
-
- *-- if not found, or field was empty, bring up the lookup ...
- if .not. lIsFound && not in table
- go top && move pointer to top of 'table'
- *-- make sure it fits on screen
- if cRetFld = cSrchFld && one browse field
- nWinWidth = len(&cSrchFld) + 3 && width
- cBarFields = cSrchFld && set the 'browse fields'
- else && else multiple ....
- nWinWidth = len(&cSrchFld)+len(&cRetFld)+5
- cBarFields = cSrchFld+", "+cRetFld
- endif
-
- *-- this is how we determine where to start the browse table ...
- nScrCol = iif(nScrCol+nWinWidth>77,77-nWinWidth,nScrCol)
- nScrRow = iif(nScrRow>14,14,nScrRow)
-
- *-- set it up ...
- define window wPick from nScrRow,nScrCol+2 to ;
- nScrRow+10,nScrCol+nWinWidth+2 panel
- activate window wPick
- *on key label ctrl-m keyboard chr(23) && when user presses <enter>,
- && force an <enter> ... weird.
-
- *-- activate
- browse fields &cBarFields freeze &cSrchFld noedit noappend;
- nodelete nomenu window wPick
- clear typeahead && in case they pressed the <Enter> key
-
- on key label ctrl-m && reset
-
- release window wPick
-
- if lastkey() # 27 && not the <Esc> key
- store &cRetFld to &cVarName && put return value into var ...
- else
- lReturn = .F.
- endif
- else
- store &cRetFld to &cVarName
- endif
-
- @nGetRow, nGetCol get &cVarName && display new value in field/memvar
- && on screen
- clear gets && clear gets from this function
-
- *-- reset work areas, and so on ...
- if .not. lExact
- set exact off
- endif
- if .not. lWasOpen
- use
- endif
- if len(cCurrBuff) # 0
- select (cCurrBuff)
- else
- select select()
- endif
-
- RETURN (lReturn)
- *-- EoF: Pick2()
-
- FUNCTION ScrRow
- *-------------------------------------------------------------------------------
- *-- Programmer..: Malcolm C. Rubel
- *-- Date........: 11/xx/1991
- *-- Notes.......: Returns the postion of the current 'GET'. If memvar
- *-- nScrRow already exists, returns the value of that, unless
- *-- it's zero, in which case we return the current position.
- *-- This is part of PICK2.
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: 05/15/1992 -- Ken Mayer (KENMAYER) to deal with a value of
- *-- 0 for the nScrRow memvar.
- *-- Calls.......: None
- *-- Called by...: Pick2() Function in PICKLIST.PRG
- *-- Usage.......: ScrRow()
- *-- Example.....: nScrRow = ScrRow()
- *-- Returns.....: Numeric -- position of cursor on screen
- *-- Parameters..: None
- *-------------------------------------------------------------------------------
-
- if type('nScrRow') # 'N' .or. nScrRow = 0
- RETURN (row())
- else
- RETURN (nScrRow)
- endif
- *-- EoF: ScrRow()
-
- FUNCTION ScrCol
- *-------------------------------------------------------------------------------
- *-- Programmer..: Malcolm C. Rubel
- *-- Date........: 11/xx/1991
- *-- Notes.......: Returns the postion of the current 'GET'. If memvar
- *-- nScrCol already exists, returns the value of that, unless
- *-- it's zero, in which case we return the current position.
- *-- This will also return a different value based on whether or
- *-- not the field has something in it or not ... This is part of
- *-- PICK2.
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: 05/15/1992 -- Ken Mayer (KENMAYER) to deal with a value of
- *-- 0 for the nScrCol memvar.
- *-- Calls.......: None
- *-- Called By...: Pick2()
- *-- Usage.......: ScrCol()
- *-- Example.....: nScrCol = ScrCol()
- *-- Returns.....: Numeric -- position of cursor on screen
- *-- Parameters..: None
- *-------------------------------------------------------------------------------
-
- if type('nScrCol') # 'N' .or. nScrCol = 0
- if isblank(cRetFld)
- RETURN col() + len(cRetFld)
- else
- RETURN col()
- endif
- else
- RETURN (nScrCol)
- endif
-
- *-- EoF: ScrCol()
-
- PROCEDURE Pick3
- *-------------------------------------------------------------------------------
- *-- Programmer..: Martin Leon (HMAN) (A-T)
- *-- Date........: 11/xx/1990
- *-- Notes.......: A "generic" PickList routine ...
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: Published in TechNotes, November, 1990 (DIYPOPUP)
- *-- Modified for dHUNG/dUFLP standards, Ken Mayer, 7/12/91
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: do Pick3 with "<cFields>",<nULRow>,<nULCol>,<nBRRow>,;
- *-- <nBRCol>, "<cNormColor>","<cFieldColor>","<cBorder>"
- *-- Example.....: Do Pick3 with "First_name+' '+Last_name",5,10,15,60,;
- *-- "rg+/gb","gb/r","DOUBLE"
- *-- Returns.....: indirectly returns the record pointer of record that was
- *-- highlighted when <Enter> was pressed.
- *-- Parameters..: cFields = fields to be displayed in picklist
- *-- nULRow = Row coordinate of upper left corner
- *-- nULCol = Column coordinate of upper left corner
- *-- nBRRow = Row coordinate of lower right corner
- *-- nBRCol = Column coordinate of lower right corner
- *-- cNormColor = Foreground/Background of normal text
- *-- cFieldColor = Foreground/Background of highlighted fields
- *-- cBorder = NONE, SINGLE, DOUBLE (defaults to Single if
- *-- sent as a nul string ("") )
- *-------------------------------------------------------------------------------
- parameter cFields, nULRow, nULCol, nBRRow, nBRCol, cNormColor, ;
- cFieldColor, cBorder
-
- cCursor = set("CURSOR")
- cEscape = set("ESCAPE")
- cTalk = set("TALK")
- set cursor off
- set escape off
- set talk off
- cTypeCheck = type("cFields")+type("nULRow")+type("nULCol")+type("nBRRow")+ ;
- type("nBRCol")+type("cNormColor")+type("cFieldColor")+type("cBorder")
-
- lError = .F.
- do case
- && Check data types
- case cTypeCheck # "CNNNNCCC"
- clear
- @ 7,17 say "Data type mismatch -- check all parameters"
- lError = .T.
-
- && Check for bottom limit with STatUS ON
- case ((nBRRow >21 .and. set("DISPLAY") # "EGA43") ;
- .or. (nBRRow >39 .and. set("DISPLAY") = "EGA43")) ;
- .and. set("STatUS") = "ON"
- clear
- @ 7,15 say "Cannot use this popup on or below STatUS line"
- lError = .T.
-
- && Check for bottom limit with STatUS ofF
- case ((nBRRow >24 .and. set("DISPLAY") # "EGA43") ;
- .or. (nBRRow >42 .and. set("DISPLAY") = "EGA43")) ;
- .and. set("STatUS") = "ofF"
- clear
- @ 7,16 say "Bottom coordinate beyond bottom of screen"
- lError = .T.
-
- && Check left & right coordinates
- case nULCol < 0 .or. nBRCol > 79
- clear
- @ 7,24 say "Invalid Column coordinate"
- lError = .T.
-
- && Check to make sure popup can display at least one record
- case nBRRow - nULRow < 2
- clear
- @ 7,19 say "Popup must be at least 3 lines high"
- lError = .T.
-
- endcase
-
- if lError
- @ 5,5 to 9,70 double
- @ 11, 32 say "Press Any Key"
- nX = 0
- do while nX = 0
- nX = inkey()
- enddo
- set cursor &cCursor
- set escape &cEscape
- set talk &cTalk
- return
- endif
-
- && Save colors of normal and fields to restor when done
- cFieldset = set("ATTRIBUTES")
- cNormSet = left(cFieldset, at(",",cFieldset)-1)
- do while "," $ cFieldset
- cFieldset = substr(cFieldset, at(",",cFieldset)+1)
- enddo
-
- && If they were provided, set to colors passed on from calling program
- if len(cNormColor) # 0
- set color of normal to &cNormColor
- endif
- if len(cFieldColor) # 0
- set color of fields to &cFieldColor
- endif
-
- nPromptW = nBRCol - nULCol - 1
- @ nULRow, nULCol clear to nBRRow, nBRCol
- @ nULRow, nULCol to nBRRow, nBRCol &cBorder
-
- if eof()
- skip -1
- endif
-
- && Save current record pointer and determine record number of top record
- nTmpRec = recno()
- go top
- nTopRec = recno()
- go nTmpRec
- nMaxRecs = nBRRow - nULRow - 1
- nKey = 0
- lGoBack = .F.
- declare aPrompt[nMaxRecs], aRec[nMaxRecs]
-
- do while .not. lGoBack
- nChcNum = 1
- nTopRow = nULRow + 1
- nLeftCol = nULCol + 1
- nRowOffset = 0
- nLastCurs = 0
-
- && This loop puts text into prompts
- do while nRowOffset + 1 <= nMaxRecs
- if .not. eof()
- cTemp = &cFields && Expands cFields into string expression
- aPrompt[nChcNum] = substr(cTemp, 1, nPromptW)
-
- && If prompt doesn't fill entire box, add spaces
- if len(aPrompt[nChcNum]) < nPromptW
- aPrompt[nChcNum] = aPrompt[nChcNum] + ;
- space(nPromptW - len(aPrompt[nChcNum]))
- endif
-
- aRec[nChcNum] = recno()
- @ nTopRow+nRowOffset , nLeftCol say aPrompt[nChcNum]
- endif
- nRowOffset = nRowOffset + 1
- nChcNum = nChcNum + 1
- skip
-
- && If last record reached, clear rest of box
- if eof()
- do while nRowOffset + 1 <= nMaxRecs
- @ nTopRow+nRowOffset, nLeftCol say space(nPromptW)
- nRowOffset = nRowOffset +1
- enddo
- exit
- endif
- enddo
-
- nHighChc = nChcNum - 1
- if nKey # 2 .and. nKey # 3 && if the last key pressed wasn't <end>
- nChcNum = 1 && or <PgDn>
- nRowOffset = 0
- else
- nChcNum = nHighChc
- nRowOffset = nHighChc - 1
- endif
-
- @ nTopRow+nRowOffset , nLeftCol get aPrompt[nChcNum]
- clear gets
-
- && This loops traps the keys
- do while .T.
- nKey = inkey()
- do case
-
- case nKey = 5 && Up arrow
-
- && If first record displayed is first record in database
- && and it is already highlighted
- if aRec[1] = nTopRec .and. nChcNum = 1
- loop
- endif
-
- && If first record is highlighted but is not top record,
- && shift prompt contents down
- if aRec[1] # nTopRec .and. nChcNum = 1
- go aRec[1]
- nX = nHighChc
- do while nX > 1
- aRec[nX] = aRec[nX - 1]
- aPrompt[nX] = aPrompt[nX - 1]
- nX = nX - 1
- enddo
-
- && Get prompt for additional record to be displayed
- skip -1
- aRec[1] = recno()
- cTemp = &cFields
- aPrompt[1] = substr(cTemp, 1, nPromptW)
- if len(aPrompt[1]) < nPromptW
- aPrompt[1] = aPrompt[1] + ;
- space(nPromptW - len(aPrompt[1]))
- endif
- skip + nMaxRecs
-
- && If maximum possible records aren't displayed
- if nHighChc < nMaxRecs
- nHighChc = nHighChc + 1
- skip -1
- aRec[nHighChc] = recno()
- cTemp = &cFields
- aPrompt[nHighChc] = substr(cTemp, 1, nPromptW)
- if len(aPrompt[nHighChc]) < nPromptW
- aPrompt[nHighChc] = aPrompt[nHighChc] + ;
- space(nPromptW - len(aPrompt[nHighChc]))
- endif
- skip
- endif
-
- && Redisplay prompts with new contents
- nX = 1
- do while nX < nHighChc + 1
- @ nTopRow + nX - 1, nLeftCol say aPrompt[nX]
- nX = nX + 1
- enddo
- nChcNum = 2
- endif
-
- nChcNum = iif(nChcNum = 1, nHighChc, nChcNum - 1)
- nRowOffset = iif(nChcNum = 1, 0, nChcNum - 1)
- nLastOne = iif(nChcNum = nHighChc, 1, nChcNum+1)
- nThisOne = nChcNum
-
- @ nTopRow+iif(nChcNum = nHighChc, 0, nRowOffset+1) , ;
- nLeftCol say aPrompt[nLastOne]
- @ nTopRow+nRowOffset , nLeftCol get aPrompt[nThisOne]
- clear gets
-
- case nKey = 24 && Dn arrow
-
- && If last prompt is highlighted and it is last record
- if eof() .and. nChcNum = nHighChc
- loop
- endif
-
- && If not at last record and bottom prompt is highlighted,
- && shift prompt contents up
- if .not. eof() .and. nChcNum = nHighChc
- nX = 1
- do while nX < nMaxRecs
- aRec[nX] = aRec[nX + 1]
- aPrompt[nX] = aPrompt[nX + 1]
- nX = nX + 1
- enddo
-
- && Get prompt for additional record to be displayed
- aRec[nMaxRecs] = recno()
- cTemp = &cFields
- aPrompt[nMaxRecs] = substr(cTemp, 1, nPromptW)
- if len(aPrompt[nMaxRecs]) < nPromptW
- aPrompt[nMaxRecs] = aPrompt[nMaxRecs] + ;
- space(nPromptW - len(aPrompt[nMaxRecs]))
- endif
- skip
-
- && Redisplay prompts with new contents
- nX = nMaxRecs
- do while nX > 0
- @ nTopRow + nX - 1, nLeftCol say aPrompt[nX]
- nX = nX - 1
- enddo
- nChcNum = nMaxRecs - 1
- endif
-
- nChcNum = iif(nChcNum < nHighChc, nChcNum + 1, 1)
- nRowOffset = iif(nChcNum = 1, 0, nChcNum - 1)
- nLastOne = iif(nChcNum = 1, nHighChc, nChcNum-1)
- nThisOne = nChcNum
-
- @ nTopRow+iif(nChcNum = 1, nHighChc-1, nRowOffset-1) , ;
- nLeftCol say aPrompt[nLastOne]
- @ nTopRow+nRowOffset , nLeftCol get aPrompt[nThisOne]
- clear gets
-
- case nKey = 13 && Enter key
- && Move record pointer and go back to calling program
- go aRec[nChcNum]
- lGoBack = .T.
- exit
-
- case nKey = 3 && PgDn key
-
- && If last record in .DBF is displayed but not highlighted,
- && move highlight to bottom and wait for next key
- if eof() .and. nChcNum # nHighChc
- @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum]
- @ nTopRow + nHighChc - 1, nLeftCol get aPrompt[nHighChc]
- clear gets
- nChcNum = nHighChc
- nRowOffset = nChcNum - 1
- loop
- endif
-
- && If highlight is not on last record that is displayed,
- && move highlight to it and wait for next key
- if nChcNum # nHighChc
- @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum]
- @ nTopRow + nHighChc - 1, nLeftCol get aPrompt[nHighChc]
- clear gets
- nChcNum = nHighChc
- nRowOffset = nChcNum - 1
- loop
- endif
-
- && Highlight is at bottom record displayed but not at eof
- && Move record pointer down to next "page" of records and
- && return to main loop
- if .not. eof()
- go aRec[1]
- skip + nMaxRecs
- lGoBack = .F.
- exit
- endif
-
- && If none of the above is true, wait for another key
- loop
-
- case nKey = 18 && PgUp key
-
- && If top record displayed is top of .DBF but it is
- && not highlighted, move highlight to it and wait for next key
- if aRec[1] = nTopRec .and. nChcNum # 1
- @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum]
- @ nTopRow, nLeftCol get aPrompt[1]
- clear gets
- nChcNum = 1
- nRowOffset = 0
- loop
- endif
-
- && If highlight is not on top record displayed, move
- && highlight to it and wait for next key
- if nChcNum # 1
- @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum]
- @ nTopRow, nLeftCol get aPrompt[1]
- clear gets
- nChcNum = 1
- nRowOffset = 0
- loop
- endif
-
- && Highlight is at top record displayed but not at top of DBF.
- && Move record pointer up one "page" worth of records and
- && return to main loop to display new prompts
- if aRec[1] # nTopRec
- go aRec[1]
- skip - nMaxRecs
- lGoBack = .F.
- exit
- endif
-
- && If none of the above is true, wait for next key
- loop
-
- case nKey = 27 && Esc key
- && Move record pointer to where it was before starting this
- && routine and return to calling program
- lAbandon = .T.
- lGoBack = .T.
- go nTmpRec
- exit
-
- case nKey = 26 && Home key
-
- && If already at top of DBF, wait for next key
- if aRec[1] = nTopRec
- loop
- else && go top and return to main loop to display new prompts
- go top
- lGoBack = .F.
- exit
- endif
-
- case nKey = 2 && End key
-
- && If last record in DBF is displayed but not highlighted,
- && move highlight to it and wait for next key
- if eof() .and. nChcNum # nHighChc
- @ nTopRow + nRowOffset, nLeftCol say aPrompt[nChcNum]
- @ nTopRow + nHighChc - 1, nLeftCol get aPrompt[nHighChc]
- clear gets
- nChcNum = nHighChc
- nRowOffset = nChcNum - 1
- loop
- endif
-
- && If last record is not displayed, go to it and
- && return to main loop
- if .not. eof()
- go BOTtoM
- skip - (nMaxRecs - 1)
- lGoBack = .F.
- exit
- endif
-
- && If none of the above is true, go back and wait for next key
- loop
-
- case nKey = 28 && F1 key
- && This is just sample code for the F1 key
- define window TempWin from 5,4 to 14,75
- activate window TempWin
- @ 1,3 say "Use cursor keys to choose. Press <Enter> to move record pointer"
- @ 2,5 say "Use <PgUp>, <PgDn>, <Home>, and <End> to see other records"
- @ 3,26 say "Use <Esc> to abandon"
- @ 5,23 say "Press Any Key to Continue"
- nX = 0
- do while nX = 0
- nX = inkey()
- enddo
- deactivate window TempWin
-
- case nKey = -1 && F2 key
- && This is just sample code for the F2 key
- save screen to sScreen
- nX = recno()
- go aRec[nChcNum]
- set cursor ON
- edit nomenu noappend nodelete next 1
- * READ is better if you already have a FORMat set.
- set cursor off
- go aRec[nChcNum]
- cTemp = &cFields && Expands cFields into string expression
- aPrompt[nChcNum] = substr(cTemp, 1, nPromptW)
- if len(aPrompt[nChcNum]) < nPromptW
- aPrompt[nChcNum] = aPrompt[nChcNum] + ;
- space(nPromptW - len(aPrompt[nChcNum]))
- endif
- restore screen from sScreen
- @ nTopRow+nRowOffset, nLeftCol get aPrompt[nChcNum]
- clear gets
- if nX <= reccount()
- go nX
- else
- go bott
- skip
- endif
- endcase
- enddo
- enddo
-
- && Put colors back to what they were and set CURSOR, escape, and TALK back
- set color of normal to &cNormSet
- set color of fields to &cFieldset
- set cursor &cCursor
- set escape &cEscape
- set talk &cTalk
-
- RETURN
- *-- EOP: Pick3
-
- FUNCTION Pick4
- *-------------------------------------------------------------------------------
- *-- Programmer..: Keith G. Chuvala (CIS: 71600,2033)
- *-- Date........: 02/16/1993
- *-- Notes.......: This is a generic picklist routine.
- *-- Written for.: dBASE IV, 1.1
- *-- Rev. History: 10/01/1992 -- Original version
- *-- 11/03/1992 -- Modified to dUFLP it (and use RECOLOR to
- *-- ensure that colors are returned properly) -- Ken Mayer
- *-- 02/16/1993 -- Minor changes to deal with small data files
- *-- by Keith.
- *-- Calls.......: ReColor PROCEDURE in PROC.PRG
- *-- Called by...: Any
- *-- Usage.......: Pick4(nRow,nCol,cTitle,cFileSpecs,cListWhat,nRetChar,;
- *-- nRetType,cColors
- *-- Example.....: ?Pick4(10,10,"Order Stock","Stock,InvNum",;
- *-- "left(invno,10)+' '+desc",4,1,"r/w,b/w,w/b")
- *-- Returns.....: number of characters from prompt()
- *-- Parameters..: nRow = Upper Left Corner Row
- *-- nCol = Upper Left Corner Column
- *-- cTitle = Title to display at top of list
- *-- cFileSpecs = "FILENAME,ORDER,SET_KEY_TO"
- *-- cListWhat = What should display as prompt
- *-- nRetChar = Number of characters of prompt to return
- *-- nReturnType = 0 = KEYB(), 1 = Normal Return
- *-- cColors = Background/Unselected Items,;
- *-- Selected letters/border, selected bar
- *-- example: rg+/gb,w+/b,w+/n
- *-- rg+/gb = unselected items (and background)
- *-- w+/b = selected letter(s)
- *-- w+/n = currently highlighted bar
- *-------------------------------------------------------------------------------
-
- para nRow,nCol,cTitle,cFileSpecs,cListWhat,nRetChar,nReturnType,cColors
-
- private nLastBar,cTalk,cStatus,cNColor,cBColor,cHColor,nPick,;
- cWindow,cCursor,cAlias,sPick,cAttrib,nLastBar, nDone,;
- nX,nP,nO,aBar,lRefresh,nLCol,nRCol,nPKey,cExact, ;
- cSeek,nOldRow,nOldWidth,xRetVal,cSetKey
-
- *-- basic environmental stuff
- cTalk = set("talk")
- set talk off
- *-- set default colors
- cNColor = "w/n"
- cBColor = "w+/n"
- cHColor = "n/w"
- *-- if user passed this parameter
- if len(cColors) > 0
- nX = at(",",cColors)
- cNColor = left(cColors,nX-1)
- cColors = substr(cColors,nX+1)
- if len(cColors) > 0
- nX = at(",",cColors)
- cBColor = iif(nX > 0,left(cColors,nX-1),cColors)
- cColors = iif(nX > 0,substr(cColors,nX+1),"")
- if len(cColors) > 0
- cHColor = cColors
- endif
- endif
- endif
-
- *-- save current screen colors and screen, modify environment some more
- cAttrib = set("attr")
- set color to &cHColor,&cNColor
- save screen to sPick
- cStatus = set("status")
- set status off
- restore screen from sPick
- cCursor = set("cursor")
- set cursor off
- cWindow = window()
- activate screen
- cExact = set("exact")
- cSeek = ""
- set exact off
- set near off
-
- *-- display
- @ 9,32 clear to 9,47
- @ 9,32 fill to 11,49 color w/n
- @ 8,31 to 10,48 color &cBColor
- @ 9,32 say " Please wait... " color &cNColor
-
- *-- create the picklist
- declare aBar[10]
- cOrder = ""
- cSetKey = ""
- cFile = cFileSpecs
- nX = at(",",cFileSpecs)
- if nX > 0
- cFile= left(cFileSpecs,nX-1)
- cFileSpecs = substr(cFileSpecs,nX+1)
- if len(cFileSpecs) > 0
- nX = at(",",cFileSpecs)
- cOrder = iif(nX>0,left(cFileSpecs,nX-1),cFileSpecs)
- cFileSpecs = iif(nX>0,substr(cFileSpecs,nX+1),"")
- if len(cFileSpecs) > 0
- cSetKey = cFileSpecs
- endif
- endif
- endif
- cAlias = alias()
- nLastBar = 9
- nP = 1
- nO = 1
- nDone = 0
- lRefresh = .t.
- lSameFile = (cAlias = upper(cFile))
- use &cFile. again in select() alias picker
- if len(tag(1)) > 0
- set order to tag(1)
- endif
- set deleted on
- if len(trim(cOrder)) > 0
- set order to &cOrder
- endif
- if len(trim(cSetKey)) > 0
- if at(",",cSetKey) > 0
- cSetKey = "range "+ cSetKey
- endif
- set nPKey to &cSetKey
- endif
- go top
- nDone = iif(reccount() < 1,2,0)
- if nRow > 14
- nRow = 14
- endif
- nOldWidth = -1
- nOldRow = -1
- nLastBar = 9
- do while nDone = 0
- if lRefresh .and. .not. eof("picker")
- nWidth = 0
- nX = 0
- do while nX < 8 .and. .not. eof("picker")
- nX = nX + 1
- aBar[nX] = &cListWhat
- if len(aBar[nX]) > nWidth
- nWidth = len(aBar[nX])
- endif
- skip 1
- enddo
- nLastBar = nX
- nLCol = nCol
- nRCol = nLCol + nWidth + 4
- do while (nRCol > 77) .and. (nLCol > 0)
- if nLCol > 1
- nRCol = nRCol - 1
- nLCol = nLCol - 1
- else
- nRCol = 77
- endif
- enddo
- if (nWidth <> nOldWidth) .or. (nLastBar <> nOldRow)
- restore screen from sPick
- @ nRow+1, nLCol+1 fill to ;
- nRow+nLastBar+2,nRCol+2 color w/n
- @ nRow , nLCol to ;
- nRow+nLastBar+1,nRCol color &cBColor
- @ nRow , nLCol+1 say '[' color &cBColor
- @ nRow , nLCol+2 say cTitle color &cNColor
- @ nRow , nLCol+2+len(cTitle) say ']' color &cBColor
- endif
- @ nRow+1, nLCol+1 clear to ;
- nRow+nLastBar ,nRCol-1
- @ nRow+1, nLCol+1 fill to ;
- nRow+nLastBar ,nRCol-1 color &cBColor
- nOldRow = nLastBar
- nOldWidth = nWidth
- nX = 1
- do while nX <= nLastBar
- @ nX+nRow,nLCol+2 say " "+aBar[nX] color &cNColor
- nX = nX + 1
- enddo
- endif
- if nP > nLastBar
- nP = nLastBar
- endif
- if nO <= nLastBar
- @ nRow+nO, nLCol+2 fill to nRow+nO,nRCol-2 color &cNColor
- endif
- @ nRow+nP, nLCol+2 fill to nRow+nP,nRCol-2 color &cHColor
- nX = at(upper(cSeek),upper(aBar[nP]))
- if nX > 0
- @ nRow+nP,nLCol+2+nX fill to nRow+nP,nLCol+1+nX+len(cSeek) ;
- color &cBColor
- endif
- nO = nP
-
- *-- start processing key strokes ...
- nPKey = inkey(0)
- do case
- case nPKey = 5 && up
- nP = nP - 1
- if nP < 1
- nPKey = 18
- nP = nLastBar
- endif
- cSeek = ""
- case nPKey = 24 && down
- nP = nP + 1
- if nP > nLastBar
- if .not. eof("picker")
- nPKey = 3
- nP = 1
- else
- nPKey = 0
- nP = nP - 1
- endif
- endif
- cSeek = ""
- endcase
- lRefresh = .t.
- do case
- case nPKey = 18 && pgup, up
- skip - 16
- if bof()
- go top
- endif
- cSeek = ""
- case nPKey = 26 && home
- go top
- nP = 1
- cSeek = ""
- case nPKey = 2 && end
- go bottom
- skip - 7
- if bof()
- go top
- else
- nP = nLastBar
- endif
- cSeek = ""
- case nPKey = 27 && esc
- nDone = 1
- case (nPKey = 13) .or. (nPkey = 23) && c/r
- nPick = aBar[nP]
- nDone = 1
- case ((nPKey >= asc(" ")) .and. (nPKey <= asc("z"))) .or. (nPKey = 127)
- if nPKey = 127
- cSeek = left(cSeek,len(cSeek)-1)
- else
- cSeek = cSeek + chr(nPKey)
- endif
- if len(trim(tag())) > 0
- seek(cSeek)
- if .not. found()
- seek(upper(cSeek))
- endif
- endif
- if .not. found()
- cSeek = left(cSeek,len(cSeek)-1)
- ?? chr(7)
- endif
- if len(trim(cSeek)) = 0
- go top
- endif
- lRefresh = .t.
- nPKey = 3
- otherwise
- if (nPKey <> 3)
- lRefresh = .f.
- endif
- endcase
- enddo
-
- *-- return something, unless <Esc> was pressed
- if nPKey <> 27
- if nReturnType = 0
- keyboard chr(26)+chr(25)+left(nPick,nRetChar)+chr(13)
- endif
- xRetVal = iif(nReturnType=0,.t.,iif(nPKey=27,"",left(nPick,nRetChar)))
- else
- xRetVal = .f.
- endif
-
- *-- cleanup
- select picker
- use
- if len(trim(cAlias)) > 0
- select (cAlias)
- endif
- if len(trim(cWindow)) > 0
- activate window &cWindow
- endif
- do recolor with cAttrib
- set status &cStatus
- set talk &cTalk
- set cursor &cCursor
- set exact &cExact
- restore screen from sPick
-
- RETURN xRetVal
- *-- EoF: Pick4()
-
- FUNCTION PopList
- *-------------------------------------------------------------------------------
- *-- Programmer..: Angus Scott-Fleming (CIS: 75500,3223)
- *-- Date........: 11/30/1992
- *-- Notes.......: Display a popup constructed from up to 9 options. The routine
- *-- then keyboards the first characters of the selected option
- *-- up to the length of the field/memvar) directly into
- *-- field/memvar. Used in place of the picture function "@M"
- *-- built-in to dBASE IV. This should be used only in a VALID
- *-- REQUIRED clause, not a WHEN clause.
- *-- Written for.: dBASE IV, 1.5
- *-- Rev. History: None
- *-- Calls.......: None
- *-- Called by...: Any
- *-- Usage.......: PopList(<cP1>,<cP2>,<cP3>,<cP4>,<cP5>,...<cP9>)
- *-- Example.....: @6,37 get m->cHanded picture "!" valid required;
- *-- poplist("Right-handed","Left-handed")
- *-- Returns.....: Logical: .T. when variable being read matches options,
- *-- .F. otherwise
- *-- Parameters..: cP1 = First parameter for list
- *-- ...
- *-- cP9 = Last this is max routine will allow ... number varies,
- *-- should always have at least two, otherwise, what's the
- *-- point?
- *-------------------------------------------------------------------------------
- parameters cP1,cP2,cP3,cP4,cP5,cP6,cP7,cP8,cP9
- private nPopLen,nPop,nPopRow,nPopCol,nPopECol,nPopBRow,nPop,cPopPar,;
- cPopRead,cPopRet,nPopInLen,cPopInput
-
- nPopLen = 0
- nPop = 0
- cPopRead = VarRead() && get memvar/field being read
- cPopInput = &cPopRead && store again?
- nPopInLen = len(cPopInput) && get length
- declare cPopBar[pcount()] && define array
- do while nPop < pcount()
- nPop = nPop + 1
- cPopPar = "cP"+ltrim(str(nPop))
- cPopBar[nPop] = &cPopPar
- nPopLen = max(nPopLen,len(cPopBar[nPop]))
- if (cPopInput=left(cPopBar[nPop],nPopInLen)) .and. ;
- (left(cPopBar[nPop],nPopInLen)=cPopInput)
- RETURN .T.
- endif
- enddo
-
- *-- set coordinates of popup (checking for edge of screen ...)
- nPopRow = row()
- nPopCol = col() + nPopInLen
- if nPopRow + pCount() + 1 > 24
- nPopRow = 23-pCount()
- endif
- nPopBRow = nPopRow + pcount() + 1
- if nPopCol + nPopLen > 79
- nPopCol = 75-nPopLen
- endif
- nPopECol = nPopCol + nPopLen + 1
-
- *-- define popup
- save screen to sPopList
- define popup PopList from nPopRow,nPopCol to nPopBRow,nPopECol
- nPop = 0
- do while nPop < pcount()
- nPop = nPop + 1
- define bar nPop of PopList prompt cPopBar[nPop]
- enddo
- on selection popup PopList deactivate popup
- activate popup PopList
-
- *-- now we have it, let's deal with output
- cPopRet = left(prompt(),nPopInLen)
-
- *-- cleanup screen and memory
- release popup PopList
- restore screen from sPopList
- release screen sPopList
-
- *-- replace data in field for user
- *-- space is necessary for the valid required error about
- *-- "Editing condition not satisified ..."
- *-- chr(26) and chr(25) move cursor to "home" and delete contents
- *-- of field, so new data can be keyboarded in
- keyboard " "+chr(26)+chr(25)+cPopRet + iif(set("CONFIRM")="ON",chr(13),"")
-
- RETURN .F.
- *-- EoF: PopList()
-
- PROCEDURE Diacrit
- *-------------------------------------------------------------------------------
- *-- Programmer..: Ken Mayer (CIS: 71333,1030)
- *-- Date........: 01/27/1993
- *-- Notes.......: Used to insert those letters with diacritical marks into
- *-- your input screens. This routine brings up a picklist with
- *-- all the standard diacrit characters built into the ASCII
- *-- character set.
- *-- NOTE: To use this routine properly, two things must be
- *-- done first:
- *-- PUBLIC n_RowPop, n_ColPop
- *-- a Call to LocPop() should be made with a WHEN clause in
- *-- the "get". See example below.
- *-- Written for.: dBASE IV, 1.5
- *-- Rev. History: 12/28/1992 -- Original
- *-- 01/27/1993 -- Modified (KJM) to cope with data entry WINDOWS
- *-- which includes restoring the active window when done.
- *-- Calls.......: LocPop() Indirectly. FUNCTION in PICKLIST.PRG
- *-- Called by...: Any (routine with a GET)
- *-- Usage.......: DO Diacrit
- *-- Example.....: public n_RowPop, n_ColPop && vital
- *-- @5,10 get cVar when LocPop(5,10) && vital
- *-- ON KEY LABEL ALT-K DO DIACRIT
- *-- read
- *-- on key label alt-k && release definition
- *-- Returns.....: Keyboards character into current "GET"
- *-- Parameters..: None
- *-------------------------------------------------------------------------------
-
- private nRow, nCol, nRow2, nCol2, cReturn
- on key label alt-k ?? chr(7) && beep if user tries to call again ...
-
- *-- first things first, define where it's to display
- cWindow = window() && save current window if there is one
- activate screen
- nRow = n_RowPop && get values from public memvars
- nCol = n_ColPop
-
- *-- bottom right corner of popup ...
- nCol2 = nCol + 5
- nRow2 = nRow + 10
-
- *-- define the popup
- define popup pDiacrit from nRow,nCol to nRow2,nCol2
- define bar 1 of pDiacrit prompt " "+chr(142)+" " && Ä
- define bar 2 of pDiacrit prompt " "+chr(143)+" " && Å
- define bar 3 of pDiacrit prompt " "+chr(146)+" " && Æ
- define bar 4 of pDiacrit prompt " "+chr(131)+" " && â
- define bar 5 of pDiacrit prompt " "+chr(132)+" " && ä
- define bar 6 of pDiacrit prompt " "+chr(133)+" " && à
- define bar 7 of pDiacrit prompt " "+chr(134)+" " && å
- define bar 8 of pDiacrit prompt " "+chr(160)+" " && á
- define bar 9 of pDiacrit prompt " "+chr(145)+" " && æ
- define bar 10 of pDiacrit prompt " "+chr(144)+" " && É
- define bar 11 of pDiacrit prompt " "+chr(136)+" " && ê
- define bar 12 of pDiacrit prompt " "+chr(137)+" " && ë
- define bar 13 of pDiacrit prompt " "+chr(138)+" " && è
- define bar 14 of pDiacrit prompt " "+chr(130)+" " && é
- define bar 15 of pDiacrit prompt " "+chr(139)+" " && ï
- define bar 16 of pDiacrit prompt " "+chr(140)+" " && î
- define bar 17 of pDiacrit prompt " "+chr(141)+" " && ì
- define bar 18 of pDiacrit prompt " "+chr(161)+" " && í
- define bar 19 of pDiacrit prompt " "+chr(147)+" " && ô
- define bar 20 of pDiacrit prompt " "+chr(148)+" " && ö
- define bar 21 of pDiacrit prompt " "+chr(149)+" " && ò
- define bar 22 of pDiacrit prompt " "+chr(162)+" " && ó
- define bar 23 of pDiacrit prompt " "+chr(153)+" " && Ö
- define bar 24 of pDiacrit prompt " "+chr(150)+" " && û
- define bar 25 of pDiacrit prompt " "+chr(129)+" " && ü
- define bar 26 of pDiacrit prompt " "+chr(151)+" " && ù
- define bar 27 of pDiacrit prompt " "+chr(163)+" " && ú
- define bar 28 of pDiacrit prompt " "+chr(154)+" " && Ü
- define bar 29 of pDiacrit prompt " "+chr(152)+" " && ÿ
- define bar 30 of pDiacrit prompt " "+chr(128)+" " && Ç
- define bar 31 of pDiacrit prompt " "+chr(165)+" " && Ñ
- define bar 32 of pDiacrit prompt " "+chr(164)+" " && ñ
-
- *-- whatta we do with it?
- on selection popup pDiacrit deactivate popup
- activate popup pDiacrit
- cPrompt = prompt()
-
- *-- Esc -> <-
- if lastkey() = 27 .or. lastkey() = 4 .or. lastkey() = 19
- cReturn = ""
- else
- cReturn = substr(cPrompt,2,1) && get the actual character ...
- endif
-
- *-- remove from memory
- release popup pDiacrit
- *-- reactivate window if there was one ...
- if .not. isblank(cWindow)
- activate window &cWindow
- endif
- *-- put into user's "Get"
- keyboard cReturn
- *-- reset ON KEY definition
- on key label alt-k do diacrit
-
- RETURN
- *-- EoP: Diacrit
-
- FUNCTION LocPop
- *-------------------------------------------------------------------------------
- *-- Programmer..: Kenneth Chan (:>Zak<:) (CIS: 71542,2712)
- *-- Date........: 01/28/1993
- *-- Notes.......: Created for diacritical routine above, to determine position
- *-- of current "Get", and then decide whether to place upper
- *-- left coordinates (in public memvars: n_RowPop, n_ColPop)
- *-- of a popup.
- *-- Written for.: dBASE IV, 1.5
- *-- Rev. History: 12/25/1992 -- Original
- *-- 12/28/1992 -- Modified to deal with positioning if get is
- *-- to far to the right on the screen, and so on (Ken Mayer).
- *-- 01/28/1993 -- Modified to handle windows on screen, giving
- *-- an absolute address. Requires user to provide coordinates
- *-- for upper left corner of window.
- *-- Calls.......: VidRow() Function in SCREEN.PRG
- *-- VidCol() Function in SCREEN.PRG
- *-- Called by...: Diacrit (Indirectly) Procedure in PICKLIST.PRG
- *-- Usage.......: LocPop(<nWidth>,<nLength>[,<nWBorder>])
- *-- Example.....: @5,10 get cVar when LocPop(5,10)
- *-- Returns.....: logical true
- *-- Parameters..: nWidth = width of popup
- *-- nLength = length of popup (how many bars should display on
- *-- screen -- used to determine if displaying above
- *-- or below ROW() of GET)
- *-- nWBorder = OPTIONAL -- if there is no border we have to back
- *-- up one, so put a '0' in here if there is no
- *-- border, otherwise, ignore this parameter.
- *-------------------------------------------------------------------------------
-
- parameters nWidth,nLength, nWBorder
- private cVar, nRow, nCol
-
- *-- get current "GET"
- cVar = varread()
-
- *-- put current position into column/row ... since cursor was just placed
- *-- into field (assuming called from WHEN clause), we are always on the
- *-- first character in the GET ...
- nRow = VidRow()
- nCol = VidCol()
-
- if type("NWBORDER") # "L" .and. nWBorder = 0
- nRow = nRow - 1
- nCol = nCol - 1
- endif
-
- *-- add it all up, see if popup coordinates are off the screen
- *-- if so, we need to display the popup UNDER the GET
- if nCol + (len(&cVar)+nWidth+1) > 79
- nRow = nRow + 1
- nCol = 79 - nWidth && put it right up against edge of screen
- else && otherwise, set column position
- nCol = nCol + len(&cVar) + 1 && add length of memvar/get
- endif
-
- *-- now to see if we're going to go off the bottom of the screen
- *-- and deal with _that_ -- displaying popup ABOVE the GET.
- nDisp = val(right(set("DISPLAY"),2)) && (EGAxx ...)
- if nRow + nLength +2 => nDisp - 1 && check for bottom of screen
- nRow = nRow - nLength - 2
- endif
-
- if type("N_ROWPOP") = "U" .or. type("N_ROWPOP") = "L"
- public n_RowPop,n_ColPop
- endif
- n_RowPop = nRow && set current position ...
- n_ColPop = nCol
-
- RETURN .t.
- *-- EoF: LocPop()
-
- *-------------------------------------------------------------------------------
- *-- Included below are any auxiliary routines needed for those above.
- *-------------------------------------------------------------------------------
-
- FUNCTION Used
- *-------------------------------------------------------------------------------
- *-- Programmer..: Ken Mayer (CIS: 71333,1030)
- *-- Date........: 02/28/1992
- *-- Notes.......: Created because the picklist routine by Malcolm Rubel
- *-- from DBA Magazine (11/91) calls a function that checks
- *-- to see if a DBF file is open ...
- *-- Written for.: dBASE IV, 1.5
- *-- Rev. History: 05/15/1992 -- Original
- *-- 02/08/1993 -- Discovered (thanks to Jay, and then Malcolm)
- *-- a much simpler way to do this ...
- *-- Called by...: Any
- *-- Calls.......: None
- *-- Usage.......: Used("<cFile>")
- *-- Example.....: if used("Library")
- *-- select library
- *-- else
- *-- select select()
- *-- use library
- *-- endif
- *-- Returns.....: Logical (.t. if file is in use, .f. if not)
- *-- Parameters..: cFile = file to check for
- *-------------------------------------------------------------------------------
-
- parameters cFile
-
- RETURN (select(cFile) # 0)
- *-- EoF: Used()
-
- FUNCTION VidRow
- *-------------------------------------------------------------------------------
- *-- Programmer..: Ken Mayer (CIS: 71333,1030)
- *-- Date........: 01/28/1993
- *-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, CIS: 72147,2635)
- *-- to return the ABSOLUTE position of the current ROW on the
- *-- screen, despite any active windows, etc.
- *-- This is based on original routines by David Frankenbach,
- *-- but includes the load/release in one routine, rather
- *-- than requiring three functions to perform this ...
- *-- ***************************
- *-- ** REQUIRES VDCURSOR.BIN **
- *-- ***************************
- *-- Written for.: dBASE IV, 1.5
- *-- Rev. History: None
- *-- Calls.......: VDCURSOR.BIN
- *-- Called by...: Any
- *-- Usage.......: VidRow()
- *-- Example.....: ?VidRow()
- *-- Returns.....: Numeric ROW position for current row on screen
- *-- Parameters..: None
- *-------------------------------------------------------------------------------
-
- private cX
-
- cX = space(2) && define argument memvar
- load vdcursor && load the .BIN file
- call vdcursor with cX && call it with the memvar
- release module vdcursor && release from memory
-
- RETURN (asc(substr(cX,2))-1) && return the value of the absolute cursor position
- *-- EoF: VidRow()
-
- FUNCTION VidCol
- *-------------------------------------------------------------------------------
- *-- Programmer..: Ken Mayer (CIS: 71333,1030)
- *-- Date........: 01/28/1993
- *-- Notes.......: Calls VDCURSOR.BIN (David Frankenbach, CIS: 72147,2635)
- *-- to return the ABSOLUTE position of the current COLUMN on the
- *-- screen, despite any active windows, etc.
- *-- This is based on original routines by David Frankenbach,
- *-- but includes the load/release in one routine, rather
- *-- than requiring three functions to perform this ...
- *-- ***************************
- *-- ** REQUIRES VDCURSOR.BIN **
- *-- ***************************
- *-- Written for.: dBASE IV, 1.5
- *-- Rev. History: None
- *-- Calls.......: VDCURSOR.BIN
- *-- Called by...: Any
- *-- Usage.......: VidCol()
- *-- Example.....: ?VidCol()
- *-- Returns.....: Numeric COLUMN position for current Col on screen
- *-- Parameters..: None
- *-------------------------------------------------------------------------------
-
- private cX
-
- cX = space(2) && define argument memvar
- load vdcursor && load the .BIN file
- call vdcursor with cX && call it with the memvar
- release module vdcursor && release from memory
-
- RETURN (asc(substr(cX,1))-1) && return the value of the absolute cursor position
- *-- EoF: VidCol()
-
-
- *-------------------------------------------------------------------------------
- *-- End of File: PICKLIST.PRG
- *-------------------------------------------------------------------------------